home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / DATETIME.SWG / 0023_Another Day of the Week.pas < prev    next >
Pascal/Delphi Source File  |  1993-06-22  |  2KB  |  58 lines
  1. ===========================================================================
  2.  BBS: The Beta Connection
  3. Date: 06-07-93 (18:50)             Number: 823
  4. From: KELLY SMALL                  Refer#: 744
  5.   To: STEPHEN WHITIS                Recvd: NO  
  6. Subj: DATE CALCULATIONS              Conf: (232) T_Pascal_R
  7. ---------------------------------------------------------------------------
  8.  SW│ Does anyone know where I can find an algorithm, or better yet TP
  9.  SW│ 5.5 code, to calculate the day of the week for a give date?
  10.  
  11. Give this a whirl:
  12.  
  13. function LeapYearOffset(M,Y:Word):Integer;
  14.   Begin
  15.   if ((Y mod 400 = 0) or ((Y mod 100 <> 0) and (Y mod 4 = 0)))
  16.         and (M > 2)
  17.     then LeapYearOffset := 1
  18.     else LeapYearOffset := 0
  19.   End;
  20.  
  21. Function DaysinMonth(dMonth,dYear:Word):Byte;
  22.   Begin
  23.   case dMonth of
  24.     1,3,5,7,8,10,12 : DaysInMonth := 31;
  25.     4,6,9,11        : DaysInMonth := 30;
  26.     2               : DaysInMonth := 28 + LeapYearOffset(3,dYear)
  27.     End;
  28.   End;
  29.  
  30. Function FindDayOfWeek(Day, Month, Year: Integer) : Byte;
  31. var
  32.   century, yr, dw: Integer;
  33. begin
  34.   if Month < 3 then
  35.   begin
  36.     Inc(Month, 10);
  37.     Dec(Year);
  38.   end
  39.   else
  40.      Dec(Month, 2);
  41.   century := Year div 100;
  42.   yr := year mod 100;
  43.   dw := (((26 * month - 2) div 10) + day + yr + (yr div 4) +
  44.     (century div 4) - (2 * century)) mod 7;
  45.   if dw < 0 then FindDayOfWeek := dw + 7
  46.   else FindDayOfWeek := dw;
  47. end;
  48.  
  49.       ⌠/elly
  50.       ⌡mall
  51.  
  52. ---
  53.  ■ JABBER v1.2 #18 ■ Bigamy: too many wives. Monogamy: see Bigamy
  54.                                             ■ KMail 2.94  The Wish Book BBS (60
  55. 2)258-7113 (6+ nodes, ring down)
  56.  * The Wish Book 602-258-7113(6 lines)10+ GIGs/The BEST board in Arizona!
  57.  * PostLink(tm) v1.06  TWB (#1032) : RelayNet(tm)
  58.